\ This module handles decompilation and debugging.

\ June 92	- fixed trap handling for user mode / virtual memory.

false	value	INMOD?			\ true if we're decompiling/debugging
					\ a module
	objPtr	THEMOD	class_is  module
					\ This is the module we're 
					\  decompiling/debugging
	handle	THEHDL


:class	MOD-DIC-MARK	super{ dic-mark }

	var	MODCXT
	var	CXTOFFS
	var	MODPTR

:m DUMP:
	." modPtr:  "  get: modPtr  .h  cr
	." modCxt:  "  get: modCxt  .h  cr
	." cxtOffs: "  get: cxtOffs .h  cr  ;m

:m SELECTMOD:	\ ( ^mod -- )
	-> theMod		\ Fails if not a module object pointer
	load: theMod		\ Ensure module is loaded
	handle: theMod  put: theHdl
	nptr: theHdl  put: modPtr
	get: modPtr  size: theHdl  +  32 -
	dup  put: modCxt  4- @  put: cxtOffs  ;m

:m SETTOMODTOP:
	#threads for
		get: modCxt
		i  2 <<  +  displace  get: cxtOffs -
		i to: links
	next
	setc: self  ;m

:m NEXTINMOD:  { \ lfa -- lfa }
	get: current  at: links
	dup  get: modPtr  <=  IF  drop  0  exit  then
	dup -> lfa
	displace  get: current  to: links
	setc: self  lfa  ;m

:m FINDINMOD:  { s255 \ addr len lfa -- cfa T  |  s255 F }
	s255 count  -> len -> addr
	addr len upper
	setToModTop: self
	begin
		nextinMod: self  -> lfa
		lfa nif  s255  false  exit  then
		lfa l>name  n>count  addr len  s=
		if  ( Found it! )
			lfa link>  true  exit
		then
	again  ;m

;class

mod-dic-mark  MM

: IN
	'  ( module cfa )
	>obj  selectMod: MM  lock: theMod
	true -> inMod?
	theMod use_module  ;

: NOTIN
	false -> inMod?  ;

: SET_MODBASE		\ Be awfully careful doing this!!
	inMod? IF  base: theMod  32766 +  ELSE  -1  THEN
	-> modbase  ;

: @ABSM  { ^rel-addr \ svModbase -- abs-addr }
	modbase -> svModbase  set_modbase
	^rel-addr  @abs
	svModbase -> modbase  ;

: (GET_CFA)  { \ svModbase -- cfa }
	Mword dup c@ over + c@  & :  =
	if  ( method for a class )
		hash  recurse			\ Recursive call to get class
		chkClass
		modbase -> svModbase  set_modbase
		findm  nip
		svModbase -> modbase
	else
		inMod?
		if		\ in a module
			findinmod: MM
			nif  true abort" not found"  then
		else		\ in main dic
			nilP -> theMod
			find  0= abort" not found"
		then
	then  ;

: GET_CFA
	(get_cfa)  ( false -> inMod? )  ;

\		========== DECOMPILER ==========

    0	value	LOCATION	\ Holds the current address in the parameter
				\  field of the definition being decompiled.
    0	value	THIS_CFA	\ Holds the current cfa.
    0	value	THAT_CFA	\ Holds the cfa called by current instruction
    2	value	GIN		\ "Go in". Holds the current amount to indent.
   10	value	SAVEBASE	\ Saves the number base.
    0	value	#P		\ Number of named parms/local vars.
false	value	CALL?		\ True if we're processing a call.
    0	value	LAST_OBJ	\ The last object referenced in debugging


: .LOCN         \ Prints the current value of LOCATION and the value of the
                \ word there.
	location  6 .r  location w@  5 .r  location 2+ w@  5 .r  ;

: DIN           \ "Do indent".  Prints the location and then indents.
	cr .locn  gin spaces
	location  addr>curs drop  ;

: NXT>	 \ ( -- n )  Fetches the longword where LOCATION points, and
	\           updates LOCATION.
	location w@  2 ++> location  ;

: .NO
	dup .  dup  decimal .  hex
	bl & ~  within? if  emit  else  drop  then  ;

: .1	1 .r  ;

: .D	4 7  within?
	IF  ." parm/loc# "  7 swap -  .1  EXIT  THEN
	dup 3 =  IF  drop  ." i"  EXIT  THEN
	." D"  .1  ;

: .A	case[	   5  ]=>  ." MP"
		[  6  ]=>  ." SP"
		[  7  ]=>  ." RP"
		default=>  ." A"  .1
	]case  ;
		
: STRING?
	that_cfa 2- w@x  -18 =  ;

: .NAME  { cfa -- }
	cfa  .id
	call?  0EXIT
	cfa  ['] (defer)  =
	if  4 ++> location  exit  then
	string?
	if	space  & " emit  location count 2dup type  & " emit
		+  align  -> location
	then  ;
    
: ?.PARAMETERS	\ ( cfa -- )  Prints any parameters associated with 
			\   this word.
	drop  ;

: ?.VALUE 	\ ( cfa -- )  Prints a value or any other useful (?) 
		\  information associated with this word.
	drop  ;


: .WORD     \ ( cfa -- )  Prints the name of the word with the given cfa.
	( ?mcf )  dup  .name  dup ?.parameters  ?.value  ;

: SHOW_CLASS  { addr \ svModbase -- }
	modbase -> svModbase
	set_modbase
	addr >obj  .class: object
	svModbase -> modbase  ;

: ?TYP  { addr -- addr }
	addr 2- w@x
	case[	   objCode  ]=>	." object of type "  addr show_class
		[  valCode  ]=>	." value "  addr @  .no
		default=>  drop
	]case  ;

local  IDENTIFY?  { \ svModbase op mode reg reg1 disp incr -- b }

: GETMODE&REG
	op  $ 7  and  -> reg
	op  $ 38 and  3 >>  -> mode  ;

: GETADDR		\ ( -- addr )
	getMode&Reg
	mode 5 =  nif  0  exit  then	\ If not d(An), just rtn zero
	reg					\ Reg
	case[	   3	]=>	lobase
		[  4	]=>	hibase
		[  5	]=>	theMod nilP <>
			if	base: theMod  32766 +
			else	0
			then
		default=>	drop  0
	]case
	location w@x  +			\ Add displ
	2 ++> location  ;

: d(An)	getAddr
	reg 2 =
	if	." ivar offs "  .
	else	cfa? if  dup .id space  then  dup  .h  ?typ
	then  ;

: TRYLIT
	reg 4 <>  ?exit
	location @  decimal . hex  4 ++> location  ;

: .ADDR
	getMode&Reg
	mode
	case[	   0  ]=>		reg .d
		[  1  ]=>		reg .a
		[  2  ]=>	." ("	reg .a  ." )"
		[  3  ]=>	." ("	reg .a  ." )+"
		[  4  ]=>	." -("	reg .a  ." )"
		[  5  ]=>	d(An)
		[  7  ]=>	tryLit
		default=>  drop
	]case  ;

: SEE_CASE	;

: DO_JSR
	call?  if  ." JSR "  else  ." JMP "  then
	getAddr  dup -> that_cfa  .name
	that_cfa  ['] (case)  =  if  see_case  then  ;

: DO_BSR
	." BSR "
	op $ FF and  -> disp  0 -> incr
	disp 0=
	if	location w@x  -> disp  2 -> incr
	else	disp  $ 7F > if  $ FFFFFF00  or> disp  then
	then
	disp location +  dup -> that_cfa  .name
	incr ++> location  ;

: DO_BCC
	." BRANCH"
	op  $ FF  and
	nif  2 ++> location  then  ;

: DO_LONG#
	location @  .no
	4 ++> location  ;

: DO_SHORT#
	op $ FF and  .no
	2 ++> location  ;

: DO_LEA
	op  $ E00 and 9 >>  -> reg1
	op  $ 41D2  = if  ." self"  exit  then
	reg1
	nif	getAddr
		reg 2 =
		if  	." ivar offs "  .
		else  	." object "  dup -> last_obj  8 -  .name
		then
	else
		." LEA  "  .addr  ."   ->  "  reg1 .a
	then  ;

: DO_MOVE
	." MOVE  "  .addr  ."  -> "
	op  3 >>  $ 38 and
	op  9 >>  $  7 and  or  -> op  .addr  ;

: 1OP		\ ( addr len )
	type  2 spaces  .addr  ;

: DO_ADDQ
	op  $ 100 and  nif  ." ADDQ #"  else  ." SUBQ #"  then
	op  9 >>  7 and
	dup nif  drop 8  then  .
	." ,"  .addr  ;

: DO_MOVEM
	op  $ FF00 and  $ 4800 =
	if	." MOVEM  regs,"  .addr
	else	." MOVEM  "  .addr  ." ,regs
	then
	2 ++> location  ;

: DO_+ETC
	op  $ F000  and
	case[	   $ D000	]=>	." ADD  "	true
		[  $ 9000	]=>	." SUB  "	true
		[  $ C000	]=>	." AND  "	true
		[  $ 8000	]=>	." OR  "	true
		[  $ B000	]=>	op $ 100 and
				if ." XOR  " else ." CMP  " then   true
		default=>	drop  ." trap "  op .h  false
	]case
	0exit
	op 9 >> 7 and  -> reg1
	op  $ 100 and
	if	reg1 .d  ."  -> "  .addr
	else	.addr  ."  -> "  reg1 .d
	then  ;

: DO_IMM
	op  8 >>  $ F  and
	case[	   0  ]=>	." OR"
		[  2  ]=>	." AND"
		[  4  ]=>	." SUB"
		[  6  ]=>	." ADD"
		[ $ A ]=>	." XOR"
		default=>	" ???"
	]case
	op 6 >> 3 and
	case[	  0 ]=>	." .B  "  location w@x  2 ++> location
		[ 1 ]=>	." .W  "  location w@x  2 ++> location
		default=>	." .L  "  location  @   4 ++> location
	]case
	." #"  .h  ."  -> "  .addr  ;

:loc IDENTIFY?
	set: fWind		\ Just in case
	true
	location w@  -> op  2 ++> location
	false -> call?  0 -> that_cfa

	op  $ FFC0 and  $ 4E80 =	if  true -> call?  do_jsr
							exit  then
	op  $ FFC0 and  $ 4EC0 =   ( JMP)  if  do_jsr	exit  then
	op  $ FF00 and  $ 6100 =	if  true -> call?  do_bsr
							exit  then
	op  $ F000 and  $ 6000 =	if  do_bcc	exit  then
	op  $ 29BC  =			if  do_long#	exit  then
	op  $ FF00 and  $ 7400 =	if  do_short#	exit  then
	op  $ 2D16 =			if  ." DUP"	exit  then
	op  $ F000 and  $ 2000 =	if  do_move	exit  then
	op  $ 4E75  =			if  ." EXIT"	exit  then
	op  $ 588E  =			if  ." DROP"	exit  then
	op  $ F000 and  $ 5000 =	if  do_addq	exit  then
	op  $ F1C0 and  $ 41C0 =	if  do_lea	exit  then
	op  $ FF00 and  dup  $ 4800 =  swap  $ 4C00 =  or
					if  do_movem	exit  then
	op  12 >>  8  $ D  within? nip  if   do_+etc	exit  then
	op  $ F000 and			nif do_imm	exit  then
	op  $ FF00 and
	case[		$ 4200	]=>	" CLR"  1op
		[	$ 4A00	]=>	" TST"  1op
			default=>	2drop  false
	]case
;loc
	

: .INST		\ Decompiles the next instruction in the current definition.
	din
	identify? drop  ;


    0	value	CL_DEPTH

: CRI		\ CR plus indent
	cr  cl_depth 2+  spaces  ;

getSelect PRINT:		constant   printID

: .IVLIST  { ^obj ^class \ svModbase thisivar ioffs ^cl -- }
	^class ifa displace  -> thisivar
	begin
		thisivar @ 0>
		if			\ Traverse n-way for superclasses
			begin	thisivar @  0exit
				thisivar @absM -> ^cl
				cri  ." superclass "
				^cl .id
				^cl  ['] object  =
				nif	2 ++> cl_depth
					^obj ^cl  recurse
					2 --> cl_depth
				then
				4 ++> thisivar
			again
		else			\ Ordinary ivar
			thisivar 8 + @absM  -> ^cl
			cri thisivar 12 + w@ -> ioffs
			." ivar offset "  ioffs .
			^cl  ['] object  =
			if	."    (bytes)"
			else	." class "  ^cl .id  2 spaces
				^obj ioffs +  printID ^cl
				modbase -> svModbase  set_modbase
				findm
				svModbase -> modbase
				>r + r>  ex-method
			then
			thisivar 4+ displace  -> thisivar
		then
	again  ;

: .SUPERS  { ^class \ svModbase thisivar ^cl -- }

\ This code is similar to .IVARS above, since we find the superclasses by traversing the ivar chain to find the n-way for the supers.  But of course we don't print any ivar information.

	^class ifa displace  -> thisivar
	begin
		thisivar @ 0>
		if			\ Traverse n-way for superclasses
			begin	thisivar @  0exit
				thisivar @absM -> ^cl
				cri  ." superclass "
				^cl .id
				^cl  ['] object  =
				nif	2 ++> cl_depth
					^cl  recurse
					2 --> cl_depth
				then
				4 ++> thisivar
			again
		else			\ Ordinary ivar
			thisivar 8 + @absM  -> ^cl
			thisivar 4+ displace  -> thisivar
		then
	again  ;

' null	vect	VV

local .WHATEVER  { cfa \ ^obj svModbase -- b }

: .OBJECT
	cfa ?typ  2 spaces
	modbase -> svModbase  set_modbase
	cfa >obj -> ^obj		\ Note: we've altered modbase, but
	print: ^obj			\ it's OK here since none of these
	^obj dup >class		\ words are local to this module.
	svModbase -> modbase
	0 -> cl_depth
	.ivlist  ;

: .CLASS
	." Class "  cfa  dup  .id  .supers  ;

: .DEFN	;

: .VALUE		cfa ?typ  ;

: .VECT
	." Vect -> "
	4 ++> cfa			\ Step past JSR doVect
	cfa @ nif
		4 ++> cfa  ." default: "
		location  cfa -> location  identify? drop  -> location
	else	cfa @abs  .id
	then  ;


:loc .WHATEVER		\ { cfa -- b }
	cfa 2- w@x
	case[	   objcode			]=>  .object  false
		[  classcode			]=>  .class   false
		[  ' .inst    2 - w@x	]=>  .defn    true
		[  ' location 2 - w@x	]=>  .value   false
		[  ' vv	   2 - w@x	]=>  .vect    false
		default=> ." ???"  drop  false
	]case
;loc

: START  { cfa \ ok? -- ok? }	\ Sets things up for a new decompilation.
               				 \   Returns true if we are to continue.
	true -> ok?
	cfa -> location
\	location  locate_src
	2 ++> gin  din
	." : "  cfa dup .id  >name  c@ 64 and if ."  IMMEDIATE"  then
	ok?
	if	cfa  -> location
	else  ( back to where we were )
		-> location  -2 ++> gin
	then
	ok?  ;  

: FINISH
	-2 ++> gin
	gin if  location locate_src  then  ;

: DONE?   ( -- b )
	location w@  $ 4E75  =
	drop false  ;


: (SEE)  { cfa \ svBase svLocation next? stop? -- }
			\ Exported.  Decompiles the word with the given cfa.
	base -> svbase  hex
	cfa locate_src
	cfa .whatever  IF  cfa start  ELSE  false  THEN
	NIF  svbase -> base  EXIT  THEN
	location @ -> this_cfa  .inst
	BEGIN
		true -> next?  false -> stop?	\ Do it unless we find out 
						\  otherwise
		key  & a  & z  within? if  bl -  then
		case[	  & Q	]=>  sp0 sp!  svbase -> base
					notin cl  cr  quit
			[  13	]=>  location -> svLocation
				that_cfa  if  2 spaces  that_cfa  (see)  then
					svLocation -> location
			[ & U	]=>  true -> stop?  false -> next?
			[ & 2	]=>  2 ++> location
			[ & P	]=>  8 --> location
			[ $ 1E	]=>  1up  false -> next?
			[ $ 1F	]=>  1dn  false -> next?
			[ $ 1C	]=>  1Lft false -> next?
			[ $ 1D	]=>  1rt  false -> next?
			[ $ 37	]=>  home false -> next?
			[ $ 31	]=>  end  false -> next?
			[ $ 39	]=>  defnUp  false -> next?
			[ $ 33	]=>  defnDn  false -> next?
			default=>  drop
		]case
		next? if  location @ -> this_cfa  .inst  then
		done? stop? or
	until
 	( Show last word )  next? if  .inst  then  finish
	svbase -> base  ;


: SEE	0 -> gin  get_cfa  (see)  ;


\			=======  DEBUGGER  =======


     variable	PROGREGS	64 allot

    0	value	CURRMODBASE

   10	array	PCSTK
    0	value	PC#

    0	value	PC			\ Current user PC on brkpt or trace trap
    0	value	STATUS			\ Current user status word ditto

    0	value	BP			\ Current breakpoint address
    0	value	BPCONT			\ Contents of that location

    0	value	IBP			\ Initial breakpoint address
    0	value	IBPCONT		\ Contents

    0	value	TTRAPVAL		\ Original contents of T trap vector

false	value	DONE?
false	value	GETOUT?
false	value	INITIALIZED?
false	value	IN_CASE?
false	value	DEBUG_STARTED?


: PUSHPC		PC# to: PCstk  1 ++> PC#  ;

: POPPC		-1 ++> PC#  PC# at: PCstk  ;

: BPON		\ ( addr -- )
	-> BP
	BP w@  -> BPcont
	$ 4E40  BP w!  patches_done  ;

: BPOFF		BPcont  BP w!  patches_done  ;

:code TOPROG	\ Returns to the user prog with tracing off.
	loc
	movem	dic[progRegs],d0-d7/a0-a6
	move.l	rel[PC],-(a7)   ; A5 won't be right for debugmod
	move.w	2(rel[status]),ccr
	rts
;code


: UP		\ End tracing current definition; resume next level up.
	PC# if	cr ." *** going up ***"
		popPC  BPon  true -> getout?
	else	cr ." *** at top already - maybe do a G instead? ****
	then  ;

: DOWN
	cr ." *** going down ***"
	location  pushPC  ;


: X	(lit-str) 99 ;		\ A dummy definition - not executed

: STEP_CASE
	true -> in_case?  ;	\ Inhibits display till we get into the stub

: NXT_CASE	\ ( -- b )
	location w@  $ 4ED1 =
	if  cr ." *** doing CASE[ selection:"  false  exit  then
	location w@  $ 4EF0 =
	if  cr ." *** doing SELECT{ selection:"  false  exit  then
	true  ;

: STEP
	call?  0exit		\ If not a call, continue normal trace
	that_cfa
	case[	  ' @(ip)	]=>	4 ++> location  true
		[ ' w@(ip)	]=>	2 ++> location  true
		[ ' (case) ], [ ' (sel) ]=>	step_case  false
		default=>	drop  true
	]case
	0exit
	location  BPon  true -> getout?  ;

: .DEPTH
	."   (" depth 2 .r  ." )"  ;

: .STK  { \ svCurs -- }
	depth  0<=  ?exit
	curs -> svCurs  -curs  20 out -  spaces
	0  depth 4 min  2-
	do
		i pick  8 .r
	-1 +loop
	svCurs -> curs  ;

: .RG	\ ( addr -- )
	@ 0  <#  # # # # # # # #  #>  type  ;

: .D&A  { cnt -- }
	& D emit  cnt .  3 spaces
	cnt 4* progRegs +  dup  .rg  10 spaces  32 +
	& A emit  cnt .  3 spaces
	.rg  ;

: .REGS
	base  hex
	8 0 do   cr  i  .d&a   loop
	-> base  ;


false	value	RES?

: *OK	& * emit  ok  ;

: DO_F  { \ svState svCurs -- }
	cr OK  state -> svState  curs -> svCurs  +curs
	begin	0 -> state  false -> res?
		query  interpret  *OK
		res?
	until
	svState -> state  svCurs -> curs  ;

: RESUME
	true -> res?  ;

: UNBUG
	initialized?  0exit
	notin  cl
	BPoff  TtrapVal if  TtrapVal  $ 24  !  then
	false -> initialized?
	drop: debugmod  ;


' null vect	SHOWME

: SHOW		\ ( cfa -- )
	-> showme  ;

local  DISPLAY  { \ svBase svCurs svLoc next? reDisp? -- }

: DISP1
	cr  0 -> out  -curs
	.locn  2 spaces  identify?  drop
	40 out -  dup 0<
	IF  drop  cr  0 -> out  40  then  spaces
	.depth  .stk  
	begin
		true -> next?  false -> reDisp?
		key  & a  & z  within? if  bl -  then
		case[	  & N	]=>  true -> done?
					BPoff
					iBP -> BP  iBPcont -> BPcont
			[ & G	]=>  true -> done?  true -> getout?
					BPoff TtrapVal  $ 24  !
					cr decimal  svCurs -> curs
			[ & Q	]=>	cr  decimal  svCurs -> curs
					unbug  quit
			[ & F	]=>  do_F
					true -> reDisp?  svLoc -> location
			[ & R	]=>  .regs  false -> next?
			[ & O	]=>  last_obj ?dup
					if  dump: **  then
					false -> next?
			[ & S	]=>  showme  false -> next?
			[ 13 ],  [ & D ]=>       down
			[ & U	]=>  up
			[ $ 1E	]=>  1up  false -> next?
			[ $ 1F	]=>  1dn  false -> next?
			[ $ 1C	]=>  1Lft false -> next?
			[ $ 1D	]=>  1rt  false -> next?
			[ $ 37	]=>  home false -> next?
			[ $ 31	]=>  end  false -> next?
			[ $ 39	]=>  defnUp  false -> next?
			[ $ 33	]=>  defnDn  false -> next?
			default=>  drop  step
		]case
		next?
	until  ;


:loc DISPLAY	\ { \ svBase svCurs svLoc next? reDisp? -- }
	debug_started?
	nif  selectDW  select: fWind  true -> debug_started?  then
	in_case?
	if	nxt_case  dup -> in_case?  exit
	then
	base -> svBase  hex  curs -> svCurs  -curs
	false -> done?  false -> getout?
	location -> svLoc
	location  addr>curs drop
	begin	location @  -> this_cfa
		disp1
		reDisp?
	nuntil  ;loc

:code  FIXMODE
	move	A5,dic[tempA5]
	move	rel[currModbase],A5
	movem	d0-d7/a0-a6,dic[progRegs]
	move	dic[tempA5],52(dic[progRegs])
	move.l	6(a7),dic[PC]
	move.w	4(a7),2(dic[status])
	move.l	(a7)+,2(a7)
	bclr	#7,(a7)
	rte
;code

:code  BPTLOC	\ We come here on a breakpoint trap
	bsr	rel[fixMode]
	subq	#2,dic[PC]	; Replace instrn at bkpt and
	move	dic[PC],a0	; don't forget to execute it!
	move.w	2(dic[BPcont]),(a0)
	jsr	dic[patches_done]
	move	a0,dic[location]	; This is location for display
	bsr	dic[display]	; display everything
	dc.w	$4E42	; TRAP 2 to set T bit & rtn
;code

:code TRACELOC
	bsr	rel[fixMode]
	tst	dic[done?]
	bne.s	done
	move	dic[PC],dic[location]   ; Next instrn is locn for displ
	bsr	dic[display]
	tst	dic[getout?]
	bne	dic[toProg]
	dc.w	$4E42	; TRAP 2 to set T bit & rtn

done	jsr	dic[cr]	; DONE? set - we're handling
	move.l	#10,dic[base]	;  it the next time in, so
	move	dic[BP],a0	;  the BP gets replaced.
	move.w	#$4E40,(a0)	; Replace BP for next time
	jsr	dic[patches_done]
	bra	dic[toProg]
;code

:code  TON		\ Returns to user's prog with tracing on.
		\ We set the TRAP 2 vector pointing here, since
		\ we need to be in supervisor mode to set the T bit.
	movem	dic[progRegs],d0-d7/a0-a6
	move.l	rel[PC],2(a7)
	move.w	2(rel[status]),(a7)
	bset	#7,(a7)
	rte
;code


: DEBUG		\ Exported.
	0 -> PC#  false -> debug_started?
	get_cfa  dup  locate_src
	initialized?
	nif	lock: debugMod		\ We must be locked since we'll
		modbase -> currModbase	\  be called from a trap
		['] bptLoc  $ 80 !	\ We use TRAP #0 as our debug brkpt
		['] Ton     $ 88 !	\ We use TRAP #2 to turn T bit on
		$ 24 @  -> TtrapVal	\ Save T trap vector (-> Macsbug?)
		['] traceLoc  $ 24 !	\ and set it to our routine TraceLoc
		true -> initialized?
	then
	( cfa )  BPon
	BP -> iBP  BPcont -> iBPcont		\ Save initial BP details
;

\			========  PROFILER  =========

    0	value	LINECNT
    0	value	PRFPTR
    0	value	LAST_PRFPTR
    0	value	SRC_POS
    0	value	SRC_LIM

	string+  $PRF
	string+  $SRC


: ADDR>PRF  { addr \ offs -- }
	addr filestart_dp -  -> offs
	reset: $prf
	BEGIN
		len: $prf  0<=  ?EXIT
		^1st: $prf  w@  offs =  ?EXIT		\ If found
		14 skip: $prf  1 ++> lineCnt
	AGAIN  ;


: FIND_DEFN_START  { addr -- }
	0 -> lineCnt
	addr  addr>prf
	<step: $prf  delete: $prf
	addr  addr>curs  dup >pos: $src  >lim: $src  ;

: FIND_DEFN_END  { \ offs addr -- }
	reset: $prf  len: $prf  0EXIT
	^1st: $prf  w@  -> offs		\ Initial offset
	14 skip: $prf			\ Skip line where defn starts
	BEGIN
		len: $prf  0EXIT
		^1st: $prf  -> addr
		addr w@  offs  >
		IF  addr w@ -> offs  ELSE  true  addr 5 + c!  THEN
		addr 4+ c@  ?EXIT
		14 skip: $prf
	AGAIN  ;


: COUNT_THIS  { addr -- }
	addr addr>prf  ^1st: $prf  -> prfPtr
	len: $prf  0EXIT
	prfPtr 2+ w@  addr w!		\ Replace instruction at breakpoint
	patches_done
	1  prfPtr 6 +  +!		\ Increment execution count
	last_time			\ Increment time
	IF	now last_time -  last_prfPtr 10 +  +!
	THEN
	prfPtr -> last_prfPtr  ;


:code PRFLOC		\ We come here on a profile trap
	push	glob[ticks]
	move	A5,dic[tempA5]
	move	rel[currModbase],A5
	pop	dic[now]
	movem	d0-d7/a0-a6,dic[progRegs]
	move	dic[tempA5],52(dic[progRegs])
	move.l	2(a7),dic[PC]
	move.w	(a7),2(dic[status])
	lea	continue,a0
	move.l	a0,2(a7)
	bclr	#7,(a7)
	rte

continue	subq	#2,dic[PC]
	move	dic[PC],a0
	move	a0,dic[this_BP]
	push	a0
	bsr	dic[count_this]
\	lea	dic[prfloc],a0
\	move	a0,$24
	dc.w	$4E42			; TRAP 2 to set T bit & rtn
;code

:code PRFTRACE		; Now we've executed the inst at bkpt
	bsr	rel[fixMode]
\	move	dic[ttrapval],$24
\	call	debugger
	move	dic[this_BP],a0
	move.w	#$4E41,(a0)
	jsr	dic[patches_done]
	movem	dic[progRegs],D0-D7/A0-A6
	move.l	rel[PC],-(a7)		; Set up for RTS
	move.l	glob[ticks],dic[last_time]
	move.w	2(rel[status]),ccr
	rts
;code


: SET_BRKPTS  { \ addr -- }
	reset: $prf
	BEGIN
		len: $prf  NIF  patches_done  EXIT  THEN
		^1st: $prf  5 + c@
		NIF
			^1st: $prf w@  filestart_dp +  -> addr
			addr w@  ^1st: $prf 2+ w!
			$ 4E41  addr w!
		THEN
		14 skip: $prf
	AGAIN  ;

: PROFILE  { \ cfa -- }
	lock: debugMod			\ We'll be entering via traps!
	modbase -> currModbase
	['] prfLoc  $ 84 !		\ We use TRAP #1 as our profile brkpt
	$ 24 @  -> TtrapVal		\ Save T-bit trap vector
	['] prfTrace  $ 24 !		\ and reset it to point to PrfTrace
	['] Ton       $ 88 !		\ We use TRAP #2 to turn T bit on
	true -> initialized?
	get_cfa -> cfa   cfa locate_src
	prof_str  ->: $src  ->: $prf
	size: $prf  0= ?error 188	\ No log file found - needed for profile
	cfa  find_defn_start
	find_defn_end
	delete: $prf
	set_brkpts
	reset: $prf  lock: $prf  ;


: SHOWP  { \ addr loc -- }
	reset: $prf  cl  bg
	."   exec   ticks"  cr 0 -> out
	BEGIN
		len: $prf
	WHILE
		^1st: $prf  -> addr
		addr 5 + c@
		NIF
			addr w@  filestart_dp +  -> loc
			addr 2+ w@  loc w!
			addr  6 + @  ?dup
			IF
				6 .r  addr 10 + @  8 .r
			THEN
		THEN
		18 out -  spaces
		nextline?: $src  IF  get: $src  type  cr  0 -> out  THEN
		14 skip: $prf
	REPEAT
	unbug  ;